SGI Hot Mix 17/Hot Mix 17.iso/HM17_SGI/research/external/callable/calltest.f

Text File | 1997-07-08 | 4.7 KB | 172 lines

C-----------------------------------------------------------------
C      Routine to print a floating point value from an IDL variable.

    SUBROUTINE PRINT_FLOAT(VPTR)

C       Declare a Fortran Record type that has a compatible form with
C       the IDL C struct IDL_VARIABLE for a floating point value.
C       Note this structure contains a union which is the size of
C       the largest data type.  This structure has been padded to
C       support the union.   Fortran records are not part of
C       F77, but most compilers have this option.

    STRUCTURE /IDL_VARIABLE/
           CHARACTER*1 TYPE
           CHARACTER*1 FLAGS
           INTEGER*4 PAD    !Pad for largest data type
           REAL*4 VALUE_F
    END STRUCTURE

    RECORD /IDL_VARIABLE/ VPTR

    WRITE(*, 10) VPTR.VALUE_F
  10    FORMAT('Program total is: ', F6.2)

    RETURN

    END

C-----------------------------------------------------------------
C  This function will be called when IDL is finished with the
C  array F.

       SUBROUTINE FREE_CALLBACK(ADDR)

          INTEGER*4 ADDR

          WRITE(*,20) LOC(ADDR)
  20      FORMAT ('IDL Released:', I12)

          RETURN

       END

C-----------------------------------------------------------------
C   This program demonstrates how to import data from a Fortran
C   program into IDL, execute IDL statements and obtain data
C   from IDL variables.

      PROGRAM CALLTEST

C   Some Fortran compilers require external definitions for IDL routines
        EXTERNAL IDL_Init !$pragma C(IDL_Init)
        EXTERNAL IDL_Cleanup !$pragma C(IDL_Cleanup)
        EXTERNAL IDL_Execute !$pragma C(IDL_Execute)
        EXTERNAL IDL_ExecuteStr !$pragma C(IDL_ExecuteStr)
        EXTERNAL IDL_ImportNamedArray !$pragma C(IDL_ImportNamedArray)
        EXTERNAL IDL_FindNamedVariable !$pragma C( IDL_FindNamedVariable )


C   Define arguments for IDL_Init routine
        INTEGER*4 ARGC
        INTEGER*4 ARGV(1)
        DATA ARGC, ARGV(1) /2 * 0/

C   Define IDL Definitions  for IDL_ImportNamedArray

        PARAMETER (IDL_MAX_ARRAY_DIM = 8)
        PARAMETER (IDL_TYP_FLOAT = 4)

        REAL*4 F(10)
        INTEGER*4 DIM(IDL_MAX_ARRAY_DIM)
        DATA DIM /10, 7*0/
        INTEGER*4 VAR_PTR     !Address of IDL variable
        EXTERNAL FREE_CALLBACK    !Declare external routine for use as arg

        PARAMETER (MAXLEN=80)   !Maximum character string length
    PARAMETER (N_ELTS=10)    !Number of elements in array F

C  Define commands to be executed by IDL

        CHARACTER*(MAXLEN) CMDS(3)
        DATA CMDS /"tmp2 = total(tmp)",
     &            "print, 'IDL total is ', tmp2",
     &            "plot, tmp"/
        INTEGER*4 CMD_ARGV(10)

C  Define widget commands to be executed by IDL

        CHARACTER*(MAXLEN) WIDGET_CMDS(5)
        DATA  WIDGET_CMDS /"a = widget_base()",
     &    "b = widget_button(a,val='Press When Done',xs=300,ys=200)",
     &    "widget_control, /realize, a",
     &    "dummy = widget_event(a)",
     &    "widget_control, /destroy, a"/

        INTEGER*4 ISTAT

C    Null Terminate command strings and store the address
C    for each command string in CMD_ARGV

        DO I = 1, 3
           CMDS(I)(MAXLEN:MAXLEN) = CHAR(0)
           CMD_ARGV(I) = LOC(CMDS(I))
        ENDDO

C   Initialize floating point array, equivalent to IDL FINDGEN(10)

        DO I = 1, N_ELTS
           F(I) = FLOAT(I-1)
        ENDDO

C   Print address of F

    WRITE(*,30) LOC(F)
   30    FORMAT('ARRAY ADDRESS:', I12)

C   Initialize Callable IDL

        ISTAT = IDL_Init(%VAL(0), ARGC, ARGV(1))

        IF (ISTAT .EQ. 1) THEN

C   Import the floating point array into IDL as a variable named TMP

          CALL IDL_ImportNamedArray('TMP'//CHAR(0), %VAL(1), DIM,
     &           %VAL(IDL_TYP_FLOAT), F, FREE_CALLBACK, %VAL(0))

C   Have IDL print the value of tmp

          CALL IDL_ExecuteStr('PRINT, TMP'//CHAR(0))

C   Execute a short sequence of IDL statements from a string array

          CALL IDL_Execute(%VAL(3), CMD_ARGV)

C   Set tmp to zero, causing IDL to release the pointer to the
C   floating point array.

          CALL IDL_ExecuteStr('TMP = 0'//CHAR(0))

C   Obtain the address of the IDL variable containing the
C   the floating point data

          VAR_PTR = IDL_FindNamedVariable('TMP2'//CHAR(0), %VAL(0))

C   Call a Fortran routine to print the value of the IDL tmp2 variable
          CALL PRINT_FLOAT(%VAL(VAR_PTR))


C    Null Terminate command strings and store the address
C    for each command string in CMD_ARGV

          DO I = 1, 5
             WIDGET_CMDS(I)(MAXLEN:MAXLEN) = CHAR(0)
             CMD_ARGV(I) = LOC(WIDGET_CMDS(I))
          ENDDO

C   Execute a small widget program.  Pressing the button allows
C   the program to end

          CALL IDL_Execute(%VAL(5), CMD_ARGV)

C   Shut down IDL
          CALL IDL_Cleanup(%VAL(0))

        ENDIF

      END